Make typed case-lambda methods work

original commit: 30cd701cf0875cf16d5e114d97e5004ca243681e

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt

@@ -9,6 +9,7 @@
          racket/match
          racket/pretty ;; DEBUG ONLY
          racket/set
+         racket/syntax
          syntax/parse
          "signatures.rkt"
          "tc-metafunctions.rkt"
@@ -1280,7 +1281,7 @@
 ;; the let-values binding for tc-expr
 (define (annotate-method stx self-type method-type)
   (syntax-parse stx
-    #:literals (let-values #%plain-lambda)
+    #:literals (let-values #%plain-lambda case-lambda)
     [(let-values ([(meth-name:id)
                    (#%plain-lambda (self-param:id id:id ...)
                      body ...)])
@@ -1310,6 +1311,19 @@
                             method-body ...)
                         #t)])
          m)]
+    ;; case-lambda methods
+    [(let-values ([(meth-name:id)
+                   (case-lambda
+                     [(self x ...) body] ...)])
+       m)
+     (define annotated-self-params
+       (for/list ([self-param (in-list (syntax->list #'(self ...)))])
+         (type-ascription-property self-param self-type)))
+     (define/with-syntax (annotated-self ...) annotated-self-params)
+     #`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type))
+                     (case-lambda
+                       [(annotated-self x ...) body] ...)])
+         m)]
     [_ (tc-error "annotate-method: internal error")]))
 
 ;; Set<Symbol> Set<Symbol> String -> Void

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt

@@ -1230,4 +1230,27 @@
                           (init-rest [rst : (List Symbol)])))
              (make-object c% "wrong"))
            #:msg #rx"expected: Symbol.*given: String"]
+   ;; check that case-lambda methods work
+   [tc-e (let ()
+           (class object%
+             (super-new)
+             (field [y : Integer 0])
+             (: m (case-> (Any -> Integer)))
+             (public m)
+             (define m (case-lambda [(x) y])))
+           (define c%
+             (class object%
+               (super-new)
+               (: m (case-> (Any -> Void)))
+               (public m)
+               (define m (case-lambda [(x) (void)]))))
+           (send (new c%) m 'anything))
+         -Void]
+   ;; fails, test that case-lambda bodies are checked
+   [tc-err (class object%
+             (super-new)
+             (: m (case-> (Any -> Integer)))
+             (public m)
+             (define m (case-lambda [(x) "bad"])))
+           #:msg #rx"expected: Integer.*given: String"]
    ))