Actual contracts for classes. Yay sstrickl!

svn: r18547

original commit: b9902e514541039ac87d47c35e9bcd9d3f37d1f3

collects/typed-scheme/private/type-contract.ss

@@ -15,7 +15,7 @@
  scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list 
  (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
  (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap)
-	       (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c object/c class?)))
+	       (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c init object/c class?)))
 
 (define (define/fixup-contract? stx)
   (or (syntax-property stx 'typechecker:contract-def)
@@ -151,13 +151,14 @@
                        [(names ...) name])
            #'(object/c (names fcn-cnts) ...))]
         ;; init args not currently handled by class/c
-        [(Class: _ _ (list (list name fcn) ...))
+        [(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...))
          (when flat? (exit (fail)))
-         (with-syntax ([(fcn-cnts ...) (for/list ([f fcn]) (t->c/fun f #:method #t))]
-                       [(names ...) name])
-           #'class?
-           #;
-           #'(class/c (names fcn-cnts) ...))]
+         (with-syntax ([(fcn-cnt ...) (for/list ([f fcn]) (t->c/fun f #:method #t))]
+                       [(name ...) name]
+                       [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))]
+                       [(by-name-init ...) by-name-init])
+           #;#'class?           
+           #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
         [(Value: '()) #'null?]
         [(Struct: nm par flds proc poly? pred? cert acc-ids)
          (cond 

collects/typed/mred/mred.ss

@@ -18,7 +18,7 @@
 (dt Text-Field% (Class () 
                        ([parent Any] [callback Any] [label String])
                        ([get-value (-> String)]
-                        [focus (-> String)])))
+                        [focus (-> Void)])))
 (dt Horizontal-Panel% (Class ()
                              ([parent Any] 
                               [stretchable-height Any #t]