Added support for configurable constructor names in require/typed.

Closes PR11171. Closes PR11194. Closes PR11314.

collects/tests/typed-scheme/succeed/pr11171.rkt

@@ -0,0 +1,14 @@
+#lang racket/load
+
+(module UNTYPED racket/base
+  (struct IntTree
+    (elem left right))
+
+  (provide (struct-out IntTree)))
+
+(module TYPED typed/racket
+  (require/typed 'UNTYPED
+                 [struct IntTree
+                   ([elem  : Integer]
+                    [left  : IntTree]
+                    [right : IntTree])]))

collects/tests/typed-scheme/succeed/pr11194.rkt

@@ -0,0 +1,14 @@
+#lang racket/load
+
+(module untyped racket
+ (struct foo (bar baz))
+ (define f (lambda (x) (+ (foo-baz x) 3)))
+
+ (provide [struct-out foo]
+          f))
+
+(module typed typed/racket
+ (require/typed 'untyped
+                [struct foo ([bar : Number] [baz : String])]))
+
+(require 'typed)

collects/tests/typed-scheme/succeed/pr11314.rkt

@@ -0,0 +1,16 @@
+#lang racket/load
+
+(module A racket
+  (define-struct point [x y])
+    (point 1 2)
+      (provide (all-defined-out)))
+
+(module B typed/racket
+  (require/typed 'A
+      [struct point ([x : Integer] [y : Integer])])
+      (point 1 2)
+      (struct: pt ([x : Integer] [y : Integer]))
+        (pt 1 2))
+
+(require 'A)
+(require 'B)

collects/tests/typed-scheme/succeed/require-struct.rkt

@@ -0,0 +1,31 @@
+#lang racket/load
+
+(module untyped racket
+ (provide (all-defined-out))
+ (struct a (v))
+ (struct b a (v))
+ (struct c (v) #:constructor-name c-maker)
+ (struct d c (v) #:constructor-name d-maker)
+ (define-struct e (v))
+ (define-struct (f e) (v)))
+
+(module typed typed/racket
+ (require/typed 'untyped
+  (struct a ((v : Integer)))
+  #;(struct (b a) ((v : String)))
+  (struct c ((v : Integer)) #:constructor-name c-maker)
+  #;(struct (d c) ((v : String)) #:constructor-name d-maker)
+  (struct e ((v : Integer)) #:extra-constructor-name make-e)
+  #;(struct (f e) ((v : String)) #:extra-constructor-name make-f))
+
+ (a 0)
+ ;(b 1 "2")
+ (c-maker 3)
+ ;(d-maker 4 "5")
+ (make-e 6)
+ ;(make-f 7 "8")
+ (e 9)
+ #;(f 10 "11"))
+
+(require 'typed)
+

collects/tests/typed-scheme/succeed/require-substruct.rkt

@@ -6,8 +6,8 @@
   (provide (all-defined-out)))
 
 (module n typed-scheme
-  (require-typed-struct X ([x : Number]) 'm)
+  (require-typed-struct X ([x : Number]) #:extra-constructor-name make-X 'm)
-  (require-typed-struct (Y X) ([y : Number]) 'm)
+  (require-typed-struct (Y X) ([y : Number]) #:extra-constructor-name make-Y 'm)
   (make-X 43)
   (define: x : Any 3)
   (if (Y? x)

collects/tests/typed-scheme/succeed/rts-prov.rkt

@@ -5,7 +5,7 @@
   (provide (all-defined-out)))
 
 (module m typed-scheme
-  (require-typed-struct q () 'l)
+  (require-typed-struct q () #:extra-constructor-name make-q 'l)
   (provide (all-defined-out)))
 
 (module n typed-scheme

collects/tests/typed-scheme/succeed/struct-out.rkt

@@ -1,3 +1,3 @@
 #lang typed-scheme
-(require-typed-struct posn ([x : Number] [y : Number]) lang/posn)
+(require-typed-struct posn ([x : Number] [y : Number]) #:extra-constructor-name make-posn lang/posn)
 (provide (struct-out posn))

collects/typed-scheme/base-env/prims.rkt

@@ -67,11 +67,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (define-syntax-class simple-clause
     #:attributes (nm ty)
     (pattern [nm:opt-rename ty]))
+  (define-splicing-syntax-class opt-constructor
+   (pattern (~optional (~seq (~or #:extra-constructor-name #:constructor-name) name:id))))
+
   (define-syntax-class struct-clause
     ;#:literals (struct)
-    #:attributes (nm (body 1))
+    #:attributes (nm (body 1) (constructor-parts 1))
-    (pattern [struct nm:opt-rename (body ...)]
+    (pattern [struct nm:opt-rename (body ...) constructor:opt-constructor]
-             #:fail-unless (eq? 'struct (syntax-e #'struct)) #f))
+             #:fail-unless (eq? 'struct (syntax-e #'struct)) #f
+             #:with (constructor-parts ...) #'constructor))
   (define-syntax-class opaque-clause
     ;#:literals (opaque)
     #:attributes (ty pred opt)
@@ -85,10 +89,10 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ lib:expr (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
      (unless (< 0 (length (syntax->list #'(sc ... strc ... oc ...))))
        (raise-syntax-error #f "at least one specification is required" stx))
-     #'(begin
+     #`(begin
 	 (require/opaque-type oc.ty oc.pred lib . oc.opt) ...
 	 (require/typed #:internal sc.nm sc.ty lib) ...
-	 (require-typed-struct strc.nm (strc.body ...) lib) ...)]
+	 (require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... lib) ...)]
     [(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
      #`(require/typed #:internal nm ty lib #,@(if (attribute parent)
                                                   #'(#:struct-maker parent)
@@ -377,48 +381,90 @@ This file defines two sorts of primitives. All of them are provided into any mod
                           [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
               #'(begin d-s dtsi)))])))))
 
+
+;Copied from racket/private/define-struct
+(define-for-syntax (self-ctor-transformer orig stx)
+  (define (transfer-srcloc orig stx)
+    (datum->syntax orig (syntax-e orig) stx orig))
+  (syntax-case stx ()
+    [(self arg ...) (datum->syntax stx
+                                   (cons (syntax-property (transfer-srcloc orig #'self)
+                                                          'constructor-for
+                                                          (syntax-local-introduce #'self))
+                                         (syntax-e (syntax (arg ...))))
+                                   stx
+                                   stx)]
+    [_ (transfer-srcloc orig stx)]))
+
+
+(define-for-syntax make-struct-info-self-ctor
+ (let ()
+  (struct struct-info-self-ctor (id info)
+          #:property prop:procedure
+                     (lambda (ins stx)
+                      (self-ctor-transformer (struct-info-self-ctor-id ins) stx))
+          #:property prop:struct-info (lambda (x) (extract-struct-info (struct-info-self-ctor-info x))))
+  struct-info-self-ctor))
+
+
 (define-syntax (require-typed-struct stx)
+  (define-syntax-class opt-parent
+    (pattern nm:id #:attr parent #'#f)
+    (pattern (nm:id parent:id)))
+
+  (define-splicing-syntax-class constructor-term
+   (pattern (~seq) #:attr name #'#f #:attr extra #f)
+   (pattern (~seq #:constructor-name name:id) #:attr extra #f)
+   (pattern (~seq #:extra-constructor-name name:id) #:attr extra #t))
+
   (syntax-parse stx #:literals (:)
-    [(_ nm:id ([fld : ty] ...) lib)
+    [(_ name:opt-parent ([fld : ty] ...) input-maker:constructor-term lib)
-     (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
+     (define has-parent? (and (syntax-e #'name.parent) #t))
-                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
+     (with-syntax* ([nm #'name.nm]
+                    [parent #'name.parent]
+                    [spec (if has-parent? #'(nm parent) #'nm)]
+                    [(struct-info _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
+                    [maker-name (if (syntax-e #'input-maker.name) #'input-maker.name #'nm)] ;New default (corresponds to how struct works)
+                    ;maker-name's symbolic form is used in the require form
+                    [id-is-ctor? (or (attribute input-maker.extra) (bound-identifier=? #'maker-name #'nm))]
+                    [internal-maker (generate-temporary #'maker-name)] ;Only used if id-is-ctor? is true
+                    [real-maker (if (syntax-e #'id-is-ctor?) #'internal-maker #'maker-name)] ;The actual identifier bound to the constructor
+                    [extra-maker (and (attribute input-maker.extra)
+                                      (not (bound-identifier=? #'make-name #'nm))
+                                      #'maker-name)])
                    (quasisyntax/loc stx
                      (begin
                        (require (only-in lib struct-info))
-                       (define-syntax nm (make-struct-info
+
+                       (define-for-syntax si
+                         (make-struct-info
                           (lambda ()
                             (list #'struct-info
-                                                  #'maker
+                                  #'real-maker
                                   #'pred
                                   (reverse (list #'sel ...))
                                   (list mut ...)
                                   #f))))
-                       (dtsi* () nm ([fld : ty] ...) #:type-only)
+
+                       (define-syntax nm
+                            (if id-is-ctor?
+                                (make-struct-info-self-ctor #'internal-maker si)
+                                si))
+
+                       (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only)
                        #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
                        #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
-                       (require/typed maker nm lib #:struct-maker #f)
+                       (require/typed (maker-name real-maker) nm lib #:struct-maker parent)
+
+                       ;This needs to be a different identifier to meet the specifications
+                       ;of struct (the id constructor shouldn't expand to it)
+                       #,(if (syntax-e #'extra-maker)
+                             #'(require/typed (maker-name extra-maker) nm lib #:struct-maker #f)
+                             #'(begin))
+
                        (require/typed lib
-                         [sel (nm -> ty)]) ...)))]
+                         [sel (nm -> ty)]) ...)))]))
-    [(_ (nm parent) ([fld : ty] ...) lib)
-     (and (identifier? #'nm) (identifier? #'parent))
-     (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
-                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
-                   #`(begin
-                       (require (only-in lib struct-info))
-                       (define-syntax nm (make-struct-info
-                                          (lambda ()
-                                            (list #'struct-info
-                                                  #'maker
-                                                  #'pred
-                                                  (list #'sel ...)
-                                                  (list mut ...)
-                                                  #f))))
-                       (dtsi* () (nm parent) ([fld : ty] ...) #:type-only)
-                       #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
-                       #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
-                       (require/typed maker nm lib #:struct-maker parent)
-                       (require/typed lib
-                         [sel (nm -> ty)]) ...))]))
 
 (define-syntax (do: stx)
   (syntax-parse stx #:literals (:)

collects/typed-scheme/scribblings/reference/special-forms.scrbl

@@ -318,10 +318,15 @@ naming a predicate, and @racket[_r] is an optionally-renamed identifier.
 @defform/subs[#:literals (struct opaque)
 (require/typed m rt-clause ...)
 ([rt-clause [r t]
-	    [struct name ([f : t] ...)]
+	    [struct name ([f : t] ...)
-	    [struct (name parent) ([f : t] ...)]
+                 struct-option ...]
-	    [opaque t pred]])
+	    [struct (name parent) ([f : t] ...)
-]{This form requires identifiers from the module @racket[m], giving
+                 struct-option ...]
+	    [opaque t pred]]
+ [struct-option
+   (code:line #:constructor-name constructor-id)
+   (code:line #:extra-constructor-name constructor-id)])]
+{This form requires identifiers from the module @racket[m], giving
 them the specified types.   
 
 The first form requires @racket[r], giving it type @racket[t].
@@ -339,7 +344,7 @@ Racket.
 @ex[(module UNTYPED racket/base
       (define n 100)
       
-      (define-struct IntTree 
+      (struct IntTree
         (elem left right))
       
       (provide n (struct-out IntTree)))

collects/typed-scheme/typecheck/tc-toplevel.rkt

@@ -115,6 +115,9 @@
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:type-only))
+                                (#%plain-app values)))
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:type-only #t)]
       ;; define-typed-struct w/ polymorphism
       [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
        (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]

collects/typed/net/cgi.rkt

@@ -2,10 +2,10 @@
   
 (require typed/private/utils)
 
-(require-typed-struct cgi-error () net/cgi)
+(require-typed-struct cgi-error () #:extra-constructor-name make-cgi-error net/cgi)
 
-(require-typed-struct (incomplete-%-suffix cgi-error)  ([chars : (Listof Char)]) net/cgi) 
+(require-typed-struct (incomplete-%-suffix cgi-error)  ([chars : (Listof Char)]) #:extra-constructor-name make-incomplete-%-suffix net/cgi) 
-(require-typed-struct (invalid-%-suffix cgi-error)  ([char : Char]) net/cgi)
+(require-typed-struct (invalid-%-suffix cgi-error)  ([char : Char]) #:extra-constructor-name make-invalid-%-suffix net/cgi)
   
 
 (require/typed/provide net/cgi

collects/typed/net/cookie.rkt

@@ -18,6 +18,6 @@
   [get-cookie (String String -> (Listof String))]
   [get-cookie/single (String String -> (Option String))])
 
-(require-typed-struct (cookie-error exn:fail) () net/cookie)
+(require-typed-struct (cookie-error exn:fail) () #:extra-constructor-name make-cookie-error net/cookie)
 
 (provide Cookie cookie? (struct-out cookie-error))

collects/typed/net/mime.rkt

@@ -10,6 +10,7 @@
                        [read : String]                                       
                        [size : Number]
                        [params : (Listof (Pair Symbol String))])
+                      #:extra-constructor-name make-disposition
                       net/mime)
 (require-typed-struct entity  ([type : (U Symbol String)] 
                                [subtype : (U Symbol String)] 
@@ -23,9 +24,11 @@
                                [fields : (Listof String)]
                                [parts : (Listof String) ]
                                [body : (Output-Port -> Void)])
+                      #:extra-constructor-name make-entity
                       net/mime)
 (require-typed-struct message 
                       ([version : String] [entity :  entity] [fields : (Listof Symbol)])
+                      #:extra-constructor-name make-message
                       net/mime)
 
 

collects/typed/net/nntp.rkt

@@ -4,6 +4,7 @@
 
 (require-typed-struct/provide
  communicator ([sender : Number] [receiver : Number] [server : String] [port : Number])
+ #:extra-constructor-name make-communicator
  net/nntp)
 
 (require/typed/provide net/nntp  
@@ -18,14 +19,24 @@
   [make-desired-header  (String -> String)]
   [extract-desired-headers ((Listof String) (Listof String) -> (Listof String))])
 
-(require-typed-struct/provide (nntp exn:fail) () net/nntp)
+(require-typed-struct/provide (nntp exn:fail)
-(require-typed-struct/provide (unexpected-response nntp) ([code : Number] [text : String]) net/nntp)
+  () #:extra-constructor-name make-nntp net/nntp)
-(require-typed-struct/provide (bad-status-line nntp) ([line : String]) net/nntp)
+(require-typed-struct/provide (unexpected-response nntp)
-(require-typed-struct/provide (premature-close nntp) ([communicator : communicator]) net/nntp)
+  ([code : Number] [text : String]) #:extra-constructor-name make-unexpected-response net/nntp)
-(require-typed-struct/provide (bad-newsgroup-line nntp) ([line : String]) net/nntp)
+(require-typed-struct/provide (bad-status-line nntp)
-(require-typed-struct/provide (non-existent-group nntp) ([group : String]) net/nntp)
+  ([line : String]) #:extra-constructor-name make-bad-status-line net/nntp)
-(require-typed-struct/provide (article-not-in-group nntp) ([article : Number]) net/nntp)
+(require-typed-struct/provide (premature-close nntp)
-(require-typed-struct/provide (no-group-selected nntp) () net/nntp)
+  ([communicator : communicator]) #:extra-constructor-name make-premature-close net/nntp)
-(require-typed-struct/provide (article-not-found nntp) ([article : Number]) net/nntp)
+(require-typed-struct/provide (bad-newsgroup-line nntp)
-(require-typed-struct/provide (authentication-rejected nntp) () net/nntp)
+  ([line : String]) #:extra-constructor-name make-bad-newsgroup-line net/nntp)
+(require-typed-struct/provide (non-existent-group nntp)
+  ([group : String]) #:extra-constructor-name make-non-existent-group net/nntp)
+(require-typed-struct/provide (article-not-in-group nntp)
+  ([article : Number]) #:extra-constructor-name make-article-not-in-group net/nntp)
+(require-typed-struct/provide (no-group-selected nntp)
+  () #:extra-constructor-name make-no-group-selected net/nntp)
+(require-typed-struct/provide (article-not-found nntp)
+  ([article : Number]) #:extra-constructor-name make-article-not-found net/nntp)
+(require-typed-struct/provide (authentication-rejected nntp)
+  () #:extra-constructor-name make-authentication-rejected net/nntp)
 

collects/typed/net/pop3.rkt

@@ -4,6 +4,7 @@
 
 (require-typed-struct/provide communicator
 			      ([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])
+                  #:extra-constructor-name make-communicator
 			      net/pop3)
 
 (require/typed/provide net/pop3
@@ -23,20 +24,31 @@
   [extract-desired-headers ((Listof String)(Listof String)-> (Listof String))])
  
 
-(require-typed-struct/provide (pop3 exn) () net/pop3)
+(require-typed-struct/provide (pop3 exn)
-(require-typed-struct/provide (cannot-connect pop3) () net/pop3)
+  () #:extra-constructor-name make-pop3 net/pop3)
-(require-typed-struct/provide (username-rejected pop3) () net/pop3)
+(require-typed-struct/provide (cannot-connect pop3)
-(require-typed-struct/provide (password-rejected pop3) () net/pop3)
+  () #:extra-constructor-name make-cannot-connect net/pop3)
-(require-typed-struct/provide (not-ready-for-transaction pop3) 
+(require-typed-struct/provide (username-rejected pop3)
-			      ([communicator : communicator]) net/pop3) 
+  () #:extra-constructor-name make-username-rejected net/pop3)
-(require-typed-struct/provide (not-given-headers pop3)
+(require-typed-struct/provide (password-rejected pop3)
-			      ([communicator : communicator] [message : Integer]) net/pop3)
+  () #:extra-constructor-name make-password-rejected net/pop3)
-(require-typed-struct/provide (illegal-message-number pop3)
+
-			      ([communicator : communicator] [message : Integer]) net/pop3)
+(require-typed-struct/provide (not-ready-for-transaction pop3)
-(require-typed-struct/provide (cannot-delete-message pop3)
+  ([communicator : communicator])
-			      ([communicator : communicator] [message : Integer]) net/pop3) 
+  #:extra-constructor-name make-not-ready-for-transaction net/pop3)
-(require-typed-struct/provide (disconnect-not-quiet pop3)
+(require-typed-struct/provide (not-given-headers pop3)
-			      ([communicator : communicator]) net/pop3)
+  ([communicator : communicator] [message : Integer])
-(require-typed-struct/provide (malformed-server-response pop3) 
+  #:extra-constructor-name make-not-given-headers net/pop3)
-			      ([communicator : communicator]) net/pop3) 
+(require-typed-struct/provide (illegal-message-number pop3)
+  ([communicator : communicator] [message : Integer])
+  #:extra-constructor-name make-illegal-message-number net/pop3)
+(require-typed-struct/provide (cannot-delete-message pop3)
+  ([communicator : communicator] [message : Integer])
+  #:extra-constructor-name make-cannot-delete-message net/pop3)
+(require-typed-struct/provide (disconnect-not-quiet pop3)
+  ([communicator : communicator])
+  #:extra-constructor-name make-disconnect-not-quiet net/pop3)
+(require-typed-struct/provide (malformed-server-response pop3)
+  ([communicator : communicator])
+  #:extra-constructor-name make-malformed-server-response net/pop3)