fix a bug in generating struct-related bindings

closes #1050

Author: capfredf

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

@@ -7,12 +7,13 @@
 (define-struct binding (name) #:transparent)
 (define-struct (def-binding binding) (ty) #:transparent)
 (define-struct (def-stx-binding binding) () #:transparent)
-(define-struct (def-struct-stx-binding def-stx-binding) (static-info constructor-type) #:transparent)
+(define-struct (def-struct-stx-binding def-stx-binding) (static-info constructor-type extra-ctor-name) #:transparent)
 
 (provide/cond-contract
  (struct binding ([name identifier?]))
  (struct (def-binding binding) ([name identifier?] [ty any/c]))
  (struct (def-stx-binding binding) ([name identifier?]))
  (struct (def-struct-stx-binding binding) ([name identifier?]
                                            [static-info (or/c #f struct-info?)]
-                                           [constructor-type any/c])))
+                                           [constructor-type any/c]
+                                           [extra-ctor-name (or/c #f identifier?)])))

typed-racket-lib/typed-racket/typecheck/provide-handling.rkt

@@ -10,6 +10,7 @@
          (types struct-table)
          (utils tc-utils)
          (env env-utils)
+         (base-env type-name-error)
          (for-syntax racket/base)
          (for-template racket/base))
 
@@ -85,24 +86,25 @@
        (match-lambda
          [(def-binding _ ty)
           (mk-value-quad internal-id new-id ty)]
-         [(def-struct-stx-binding _ (? struct-info? si) constr-type)
-          (mk-struct-syntax-quad internal-id new-id si constr-type)]
+         [(def-struct-stx-binding _ (? struct-info? si) constr-type extra-ctor-name)
+          (mk-struct-syntax-quad internal-id new-id si constr-type extra-ctor-name)]
          [(def-stx-binding _)
           (mk-syntax-quad internal-id new-id)])]
       ;; otherwise, not defined in this module, not our problem
       [else (mk-ignored-quad internal-id)]))
 
   ;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type? -> quad/c
   ;; This handles `(provide s)` where `s` was defined with `(struct s ...)`. 
-  (define (mk-struct-syntax-quad internal-id new-id si constr-type)
-    (define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
+  (define (mk-struct-syntax-quad internal-id new-id si constr-type extra-ctor-name)
     (match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si))
     (define-values (defns export-defns new-ids aliases)
       (for/lists (defns export-defns new-ids aliases)
         ([e (in-list (list* type-desc pred super accs))])
         (if (identifier? e)
             (mk e)
             (mk-ignored-quad e))))
+
+    (define type-is-constructor? (or (free-identifier=? new-id constr) extra-ctor-name))
     ;; Here, we recursively handle all of the identifiers referenced
     ;; in this static struct info.
     (define-values (constr-defn constr-export-defn constr-new-id constr-aliases)
@@ -143,7 +145,8 @@
                                 (list #,@(map (lambda (x) #'#f) accs)) super*)))
                 #,(if type-is-constructor?
                       #'(make-struct-info-self-ctor constr* info)
-                      #'info)))
+                      #'(lambda (stx)
+                          (type-name-error stx)))))
             (define-syntax export-id
               (make-rename-transformer #'protected-id)))
         #'export-id

typed-racket-lib/typed-racket/typecheck/tc-structs.rkt

@@ -300,7 +300,8 @@
    (cons
     (make-def-struct-stx-binding (struct-names-type-name names)
                                  si
-                                 (def-binding-ty constructor-binding))
+                                 (def-binding-ty constructor-binding)
+                                 extra-constructor)
     bindings)))
 
 (define/cond-contract (register-non-prefab-bindings! sty names desc si)
@@ -378,7 +379,8 @@
       (values (cons constructor-binding extra-constructor-bindings)
               (append (cons (make-def-struct-stx-binding (struct-names-type-name names)
                                                          si
-                                                         constructor-type)
+                                                         constructor-type
+                                                         extra-constructor)
                             extra-constructor-bindings)
                       bindings))))
 

typed-racket-test/fail/gh-issue-1050.rkt

@@ -0,0 +1,10 @@
+#;
+(exn-pred exn:fail:syntax? #rx"type-check: type name used out of context.*? type: Exp")
+#lang typed/racket/base
+
+(module typed1 typed/racket/base
+  (provide (except-out (all-defined-out) make-exp))
+  (struct Exp () #:constructor-name make-exp))
+
+(require 'typed1)
+(Exp)