From c8c1cdc655a92f090ac29bdf4f0c7c5183456bd0 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 29 Jun 2011 17:02:29 -0400
Subject: [PATCH] Make TR provided struc-infos act like constructors. Closes
 PR11578. Closes PR11866.

original commit: d0cfebd5b464076bbfa136861ffbaaae2d400620
---
 .../tests/typed-scheme/succeed/pr11578.rkt    | 12 ++++++++
 .../tests/typed-scheme/succeed/pr11866.rkt    | 10 +++++++
 .../typecheck/provide-handling.rkt            |  6 +++-
 collects/typed-scheme/utils/utils.rkt         | 29 ++++++++++++++++++-
 4 files changed, 55 insertions(+), 2 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/pr11578.rkt
 create mode 100644 collects/tests/typed-scheme/succeed/pr11866.rkt

diff --git a/collects/tests/typed-scheme/succeed/pr11578.rkt b/collects/tests/typed-scheme/succeed/pr11578.rkt
new file mode 100644
index 00000000..4cf7a987
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/pr11578.rkt
@@ -0,0 +1,12 @@
+#lang racket/load
+
+(module a typed/racket/base
+  (provide foo)
+    (struct: foo ()))
+
+(module b racket/base
+  (require 'a)
+    (foo))
+
+
+(require 'b)
diff --git a/collects/tests/typed-scheme/succeed/pr11866.rkt b/collects/tests/typed-scheme/succeed/pr11866.rkt
new file mode 100644
index 00000000..0c60e742
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/pr11866.rkt
@@ -0,0 +1,10 @@
+#lang racket/load
+(module a typed/racket
+  (struct: S ((x : Integer)) #:transparent)
+    (provide (all-defined-out)))
+
+(module b typed/racket/no-check
+  (require 'a)
+    (S 5))
+
+(require 'b)
diff --git a/collects/typed-scheme/typecheck/provide-handling.rkt b/collects/typed-scheme/typecheck/provide-handling.rkt
index 368df3ef..ca048a4c 100644
--- a/collects/typed-scheme/typecheck/provide-handling.rkt
+++ b/collects/typed-scheme/typecheck/provide-handling.rkt
@@ -51,6 +51,7 @@
     (define (mk-untyped-syntax b defn-id internal-id)
       (match b
         [(def-struct-stx-binding _ (? struct-info? si))
+         (define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
          (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
            (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
                                                                        (mk e)
@@ -63,7 +64,10 @@
                #`(begin
                    #,@defns
                    (define-syntax #,defn-id
-                     (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
+                     (let ((info (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*)))
+                      #,(if type-is-constructor?
+                            #'(make-struct-info-self-ctor constr* info)
+                            #'info)))))))]
         [_
          #`(define-syntax #,defn-id
              (lambda (stx)
diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt
index a0c03ea4..093e0f7a 100644
--- a/collects/typed-scheme/utils/utils.rkt
+++ b/collects/typed-scheme/utils/utils.rkt
@@ -8,7 +8,7 @@ at least theoretically.
 (require (for-syntax racket/base syntax/parse racket/string)
          racket/contract racket/require-syntax
 	 racket/provide-syntax racket/unit (prefix-in d: unstable/debug)
-	 racket/pretty mzlib/pconvert syntax/parse)
+	 racket/struct-info racket/pretty mzlib/pconvert syntax/parse)
 
 ;; to move to unstable
 (provide reverse-begin list-update list-set debugf debugging? dprintf)
@@ -237,3 +237,30 @@ at least theoretically.
 (define debugging? (make-parameter #f))
 (define-syntax-rule (debugf f . args) (if (debugging?) (d:debugf f . args) (f . args)))
 (define (dprintf . args) (when (debugging?) (apply d:dprintf args)))
+
+
+(provide make-struct-info-self-ctor)
+;Copied from racket/private/define-struct
+;FIXME when multiple bindings are supported
+(define (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 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))