Fix delay/force.

svn: r11841

collects/typed-scheme/private/type-effect-convenience.ss

@@ -104,8 +104,10 @@
 (define (make-arr-dots dom rng dty dbound)
   (make-arr* dom rng #f (cons dty dbound) null null))
 
-(define (make-promise-ty t)
-  (make-Struct (string->uninterned-symbol "Promise") #f (list t) #f #f #'promise? values))
+(define make-promise-ty
+  (let ([s (string->uninterned-symbol "Promise")])
+    (lambda (t)
+      (make-Struct s #f (list t) #f #f #'promise? values))))
 
 (define N (make-Base 'Number))
 (define -Integer (make-Base 'Integer))

collects/typed-scheme/typecheck/tc-app-unit.ss

@@ -606,10 +606,27 @@
     [(Value: '()) null]
     [_ (int-err "bad value in type->list: ~a" t)]))
 
+;; id: identifier
+;; sym: a symbol
+;; mod: a quoted require spec like 'scheme/base
+;; is id the name sym defined in mod?
+(define (id-from? id sym mod)
+  (and (eq? (syntax-e id) sym)
+       (eq? (module-path-index-resolve (syntax-source-module id))
+            ((current-module-name-resolver) mod #f #f #f))))
+
 (define (tc/app/internal form expected)
   (kernel-syntax-case* form #f 
     (values apply not list list* call-with-values do-make-object make-object cons
-            andmap ormap) ;; the special-cased functions   
+            andmap ormap) ;; the special-cased functions
+    ;; special case for delay
+    [(#%plain-app 
+      mp1 
+      (#%plain-lambda () 
+        (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
+     (and (id-from? #'mp1 'make-promise 'scheme/promise)
+          (id-from? #'mp2 'make-promise 'scheme/promise))
+     (ret (-Promise (tc-expr/t #'e)))]
     ;; special cases for classes
     [(#%plain-app make-object cl . args)     
      (check-do-make-object #'cl #'args #'() #'())]