fix the constructor expr in the exported structure's struct-info

Author: capfredf

typed-racket-lib/typed-racket/typecheck/def-binding.rkt

@@ -116,7 +116,7 @@
          ;; avoid generating the quad for constr twice.
          ;; skip it when the binding is for the type name
          [(and (free-identifier=? internal-id sname) (free-identifier=? constr internal-id))
-          (super-mk-quad (make-def-binding constr constr-type) (generate-temporary constr) def-tbl pos-blame-id mk-redirect-id)]
+          (super-mk-quad (make-def-binding constr constr-type) (freshen-id constr) def-tbl pos-blame-id mk-redirect-id)]
          [else
           (make-quad constr def-tbl pos-blame-id mk-redirect-id)]))
 
@@ -127,6 +127,13 @@
      (with-syntax* ([id internal-id]
                     [export-id new-id]
                     [protected-id (freshen-id #'id)]
+                    ;; when the struct name is also the constructor name, we put
+                    ;; the former in the struct info, because it is the
+                    ;; exporting binding. Otherwise, we put the latter in the
+                    ;; struct info
+                    [constr-in-si* (if (free-identifier=? new-id constr-new-id)
+                                       new-id
+                                       constr-new-id)]
                     [type-name tname])
        (values
         #`(begin
@@ -146,7 +153,7 @@
             ;; a protected version in the submodule, since that
             ;; wouldn't be accessible by `syntax-local-value`.
             (define-syntax protected-id
-              (let ((info (list type-desc* (syntax export-id) pred* (list accs* ...)
+              (let ((info (list type-desc* (syntax constr-in-si*) pred* (list accs* ...)
                                 (list #,@(map (lambda (x) #'#f) accs)) super*)))
                 (make-struct-info-wrapper* constr* info (syntax type-name) #,sname-is-constructor?)))
             (define-syntax export-id

typed-racket-test/succeed/test-struct-info.rkt

@@ -0,0 +1,40 @@
+#lang racket/base
+(module test racket/base
+  (require (for-syntax racket/base syntax/parse racket/struct-info racket/match))
+
+  (define-syntax (get-constr stx)
+    (syntax-parse stx
+      [(_ sname:id)
+       (define si (extract-struct-info (syntax-local-value #'sname (lambda () #f))))
+       (match-define (list* struct-desc constr rst) si)
+       constr]))
+    (provide get-constr))
+
+(module typed typed/racket/base
+  (require (submod ".." test))
+  (require typed/rackunit)
+  (struct kiwi ())
+  (struct apple () #:constructor-name make-apple)
+  (struct pear () #:type-name PEAR)
+  (struct dragon-fruit () #:type-name DragonFruit #:constructor-name make-dragon-fruit)
+  (provide (struct-out apple)
+           (struct-out kiwi)
+           (struct-out PEAR)
+           (struct-out DragonFruit))
+
+  (check-equal? (object-name (get-constr apple)) 'make-apple)
+  (check-equal? (object-name (get-constr kiwi)) 'kiwi)
+  (check-equal? (object-name (get-constr apple)) 'make-apple)
+  (check-equal? (object-name (get-constr pear)) 'pear)
+  (check-equal? (object-name (get-constr dragon-fruit)) 'make-dragon-fruit)
+  (check-equal? (object-name (get-constr DragonFruit)) 'make-dragon-fruit)
+  (check-equal? (object-name (get-constr PEAR)) 'pear))
+
+(require rackunit)
+(require 'typed)
+(require 'test)
+(check-equal? (object-name (get-constr apple)) 'make-apple)
+(check-equal? (object-name (get-constr kiwi)) 'kiwi)
+(check-equal? (object-name (get-constr apple)) 'make-apple)
+(check-equal? (object-name (get-constr DragonFruit)) 'make-dragon-fruit)
+(check-equal? (object-name (get-constr PEAR)) 'pear)