Add `struct:'

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

@@ -0,0 +1,7 @@
+#lang typed/racket
+
+(struct: x ([y : Number]))
+
+(x 1)
+(x-y (x 7))
+(ann x? (Any -> Boolean : x))

collects/typed-scheme/private/prims.rkt

@@ -26,6 +26,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
                      [define-typed-struct/exec define-struct/exec:]))
 
 (require "../utils/utils.rkt"
+         racket/base
 	 (for-syntax 
           syntax/parse
 	  syntax/private/util
@@ -296,7 +297,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
                  (define-typed-struct-internal (vars ...)
                    #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))
 
-(define-syntax (define-typed-struct stx)
+(define-syntaxes (define-typed-struct struct:)
+  (let ()
     (define-syntax-class fld-spec
       #:literals (:)
       #:description "[field-name : type]"
@@ -307,11 +309,22 @@ This file defines two sorts of primitives. All of them are provided into any mod
       (pattern (name:id super:id))
       (pattern name:id
                #:with super #f))    
+    (define-splicing-syntax-class struct-name/new
+      #:description "struct name (with optional super-struct name)"
+      (pattern (~seq name:id super:id)
+               #:attr old-spec #'(name super)
+               #:with new-spec #'(name super))
+      (pattern name:id
+               #:with super #f
+               #:attr old-spec #'name
+               #:with new-spec #'(name)))
+    (define (mutable? opts) 
+      (if (memq '#:mutable (syntax->datum opts)) '(#:mutable) '()))
+    (values     
+     (lambda (stx)
        (syntax-parse stx
          [(_ nm:struct-name (fs:fld-spec ...) . opts)
-     (let ([mutable (if (memq '#:mutable (syntax->datum #'opts))
+          (let ([mutable (mutable? #'opts)])
-                        '(#:mutable)
-                        '())])
             (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
                                                 'typechecker:ignore #t)]
                           [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
@@ -321,6 +334,27 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                               'typechecker:ignore #t)]
                         [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))])
             #'(begin d-s dtsi))]))
+     (lambda (stx)
+       (syntax-parse stx
+         [(_ nm:struct-name/new (fs:fld-spec ...) . opts)
+          (let ([mutable (mutable? #'opts)]
+                [cname (datum->syntax #f (syntax-e #'nm.name))])
+            (with-syntax ([d-s (syntax-property (quasisyntax/loc stx
+                                                  (struct #,@(attribute nm.new-spec) (fs.fld ...) 
+                                                          #:extra-constructor-name #,cname
+                                                          . opts))
+                                                'typechecker:ignore #t)]
+                          [dtsi (quasisyntax/loc stx (dtsi* () nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
+              #'(begin d-s dtsi)))]
+         [(_ (vars:id ...) nm:struct-name/new (fs:fld-spec ...) . opts)
+          (let ([cname (datum->syntax #f (syntax-e #'nm.name))])
+            (with-syntax ([d-s (syntax-property (quasisyntax/loc stx 
+                                                  (struct #,@(attribute nm.new-spec) (fs.fld ...)
+                                                          #:extra-constructor-name #,cname
+                                                          . opts))
+                                                'typechecker:ignore #t)]
+                          [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname))])
+              #'(begin d-s dtsi)))])))))
 
 (define-syntax (require-typed-struct stx)
   (syntax-parse stx #:literals (:)
@@ -347,8 +381,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ (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 ...)))]
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
-                    #;[(parent-tys ...) (Struct-flds (parse-type #'parent))])
                    #`(begin
                        (require (only-in lib struct-info))
                        (define-syntax nm (make-struct-info 

collects/typed-scheme/scribblings/ts-reference.scrbl

@@ -367,14 +367,26 @@ types.  In most cases, use of @racket[:] is preferred to use of @racket[define:]
 
 @subsection{Structure Definitions}
 @defform/subs[
-(define-struct: maybe-type-vars name-spec ([f : t] ...))
+(struct: maybe-type-vars name-spec ([f : t] ...) options ...)
 ([maybe-type-vars code:blank (v ...)]
- [name-spec name (name parent)])]{
+ [name-spec name (code:line name parent)]
+ [options #:transparent #:mutable])]{
  Defines a @rtech{structure} with the name @racket[name], where the
- fields @racket[f] have types @racket[t].  When @racket[parent], the
+ fields @racket[f] have types @racket[t], similar to the behavior of @racket[struct].
+  When @racket[parent] is present, the
 structure is a substructure of @racket[parent].  When
 @racket[maybe-type-vars] is present, the structure is polymorphic in the type
- variables @racket[v].}
+ variables @racket[v].
+
+Options provided have the same meaning as for the @racket[struct] form.}
+
+
+@defform/subs[
+(define-struct: maybe-type-vars name-spec ([f : t] ...) options ...)
+([maybe-type-vars code:blank (v ...)]
+ [name-spec name (name parent)]
+ [options #:transparent #:mutable])]{Legacy version of @racket[struct:], 
+corresponding to @racket[define-struct].}
                                  
 @defform/subs[
 (define-struct/exec: name-spec ([f : t] ...) [e : proc-t])

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

@@ -173,7 +173,7 @@
 
 ;; check and register types for a polymorphic define struct
 ;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
-(define (tc/poly-struct vars nm/par flds tys)
+(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f])
   ;; parent field types can't actually be determined here
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
   ;; create type variables for the new type parameters
@@ -197,6 +197,7 @@
   ;; that the outside world will see
   ;; then register them
   (mk/register-sty nm flds parent-name parent-field-types types
+                   #:maker maker
                    ;; wrap everything in the approriate forall
                    #:wrapper (λ (t) (make-Poly tvars t))
                    #:type-wrapper (λ (t) (make-App t new-tvars #f))

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

@@ -94,6 +94,16 @@
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) 
 		  #:maker #'m #:constructor-return #'t)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
+						#:maker m)) 
+                                (#%plain-app values)))
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) 
+		  #:maker #'m)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...)
+						#:maker m)) 
+                                (#%plain-app values)))
+       (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
+                       #:maker #'m)]
       [(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)]