diff --git a/disjoint-containers.cabal b/disjoint-containers.cabal
--- a/disjoint-containers.cabal
+++ b/disjoint-containers.cabal
@@ -1,5 +1,5 @@
 name: disjoint-containers
-version: 0.2.1
+version: 0.2.2
 synopsis: Disjoint containers
 description: Disjoint containers
 homepage: https://github.com/andrewthad/disjoint-containers#readme
@@ -22,6 +22,7 @@
       base >= 4.7 && < 5
     , transformers >= 0.5 && < 0.6
     , containers >= 0.5 && < 0.6
+    , aeson >= 0.11 && < 1.3
   default-language: Haskell2010
 
 test-suite test
@@ -33,6 +34,8 @@
     , disjoint-containers
     , containers
     , QuickCheck
+    , quickcheck-classes
+    , aeson
   default-language: Haskell2010
 
 test-suite doctest
diff --git a/src/Data/DisjointMap.hs b/src/Data/DisjointMap.hs
--- a/src/Data/DisjointMap.hs
+++ b/src/Data/DisjointMap.hs
@@ -8,13 +8,10 @@
 
 {-|
 Maps with disjoint sets as the key. The type in this module can be
-understood as:
+roughly understood as:
 
-> DisjointMap k v ≡ Map (DisjointSet k) v
+> DisjointMap k v ≈ Map (Set k) v
 
-However, actually using a 'Map' with @DisjointSet@ as the key
-would offer terrible performance. This is because the 'Ord'
-instance for @DisjointSet@ cannot be made to perform well.
 Internally, @DisjointMap@ is implemented like a disjoint set
 but the data structure that maps representatives to their rank also holds the value
 associated with that representative element. Additionally, it holds the set
@@ -57,6 +54,8 @@
 import Data.Bifunctor (first)
 import Data.Foldable (Foldable)
 import Data.Maybe (fromMaybe)
+import Data.Aeson (ToJSON(..),FromJSON(..))
+import Data.Foldable (foldlM)
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import qualified GHC.OldList as L
@@ -88,6 +87,41 @@
 instance (Show k, Ord k, Show v) => Show (DisjointMap k v) where
   show = showDisjointSet
 
+instance (ToJSON k, ToJSON v) => ToJSON (DisjointMap k v) where
+  toJSON = toJSON . toSets
+
+instance (FromJSON k, FromJSON v, Ord k) => FromJSON (DisjointMap k v) where
+  parseJSON x = do
+    theSets <- parseJSON x
+    case fromSets theSets of
+      Nothing -> fail "the sets comprising the DisjointSet were not distinct"
+      Just s -> return s
+
+fromSets :: Ord k => [(Set k,v)] -> Maybe (DisjointMap k v)
+fromSets xs = case unionDistinctAll (map fst xs) of
+  Nothing -> Nothing
+  Just _ -> Just (unsafeFromSets xs empty)
+
+unsafeFromSets :: Ord k => [(Set k,v)] -> DisjointMap k v -> DisjointMap k v
+unsafeFromSets ys !ds@(DisjointMap p r) = case ys of
+  [] -> ds
+  (x,v) : xs -> case setLookupMin x of
+    Nothing -> unsafeFromSets xs ds
+    Just m -> unsafeFromSets xs $ DisjointMap
+      (M.union (M.fromSet (\_ -> m) x) p)
+      (M.insert m (Ranked 0 x v) r)
+  
+
+unionDistinctAll :: Ord a => [Set a] -> Maybe (Set a)
+unionDistinctAll = foldlM unionDistinct S.empty
+
+unionDistinct :: Ord a => Set a -> Set a -> Maybe (Set a)
+unionDistinct a b = 
+  let s = S.union a b
+   in if S.size a + S.size b == S.size s
+        then Just s
+        else Nothing
+
 showDisjointSet :: (Show k, Ord k, Show v) => DisjointMap k v -> String
 showDisjointSet = show . toLists
 
@@ -199,7 +233,8 @@
   Nothing -> empty
   Just x ->
     let p = M.fromSet (\_ -> x) s
-        r = M.singleton x (Ranked 1 s v)
+        rank = if S.size s == 1 then 0 else 1
+        r = M.singleton x (Ranked rank s v)
     in DisjointMap p r
 
 setLookupMin :: Set a -> Maybe a
diff --git a/src/Data/DisjointSet.hs b/src/Data/DisjointSet.hs
--- a/src/Data/DisjointSet.hs
+++ b/src/Data/DisjointSet.hs
@@ -7,6 +7,10 @@
 Persistent disjoint-sets. Disjoint-sets are a set of elements 
 with equivalence relations defined between elements, i.e. 
 two elements may be members of the same equivalence set.
+The type in this module can be roughly understood as:
+
+> DisjointSet a ≈ Set (Set a)
+
 This library provides the fundamental operations classically
 known as @union@, @find@, and @makeSet@. It also offers
 novelties like a 'Monoid' instance for disjoint sets
@@ -28,11 +32,16 @@
   , equivalent
   , sets
   , values
+  , equivalences
   , representative
   , representative'
     -- * Conversion
   , toLists
+  , fromLists
+  , toSets
+  , fromSets
   , pretty
+  , showInternal
     -- * Tutorial
     -- $tutorial
   ) where
@@ -47,6 +56,8 @@
 import Data.Set (Set)
 import Data.Semigroup (Semigroup)
 import Data.Maybe (fromMaybe)
+import Data.Aeson (ToJSON(..),FromJSON(..))
+import Data.Foldable (foldlM)
 import qualified Data.Semigroup
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
@@ -54,8 +65,54 @@
 
 data DisjointSet a = DisjointSet
   !(Map a a) -- parents
-  !(Map a Int) -- ranks
+  !(Map a (RankChildren a)) -- ranks
 
+data RankChildren a = RankChildren {-# UNPACK #-} !Int !(Set a)
+  deriving Show
+
+data RevealDisjointSet a = RevealDisjointSet
+  !(Map a a)
+  !(Map a (RankChildren a))
+  deriving Show
+
+showInternal :: Show a => DisjointSet a -> String
+showInternal (DisjointSet p r) = show (RevealDisjointSet p r)
+
+instance ToJSON a => ToJSON (DisjointSet a) where
+  toJSON = toJSON . toSets
+
+instance (Ord a, FromJSON a) => FromJSON (DisjointSet a) where
+  parseJSON x = do
+    theSets <- parseJSON x
+    case fromSets theSets of
+      Nothing -> fail "the sets comprising the DisjointSet were not distinct"
+      Just s -> return s
+
+fromSets :: Ord a => [Set a] -> Maybe (DisjointSet a)
+fromSets xs = case unionDistinctAll xs of
+  Nothing -> Nothing
+  Just _ -> Just (unsafeFromSets xs empty)
+
+unsafeFromSets :: Ord a => [Set a] -> DisjointSet a -> DisjointSet a
+unsafeFromSets ys !ds@(DisjointSet p r) = case ys of
+  [] -> ds
+  x : xs -> case setLookupMin x of
+    Nothing -> unsafeFromSets xs ds
+    Just m -> unsafeFromSets xs $ DisjointSet
+      (M.union (M.fromSet (\_ -> m) x) p)
+      (M.insert m (RankChildren 0 x) r)
+  
+
+unionDistinctAll :: Ord a => [Set a] -> Maybe (Set a)
+unionDistinctAll = foldlM unionDistinct S.empty
+
+unionDistinct :: Ord a => Set a -> Set a -> Maybe (Set a)
+unionDistinct a b = 
+  let s = S.union a b
+   in if S.size a + S.size b == S.size s
+        then Just s
+        else Nothing
+
 instance Ord a => Monoid (DisjointSet a) where
   mappend = append
   mempty = empty
@@ -73,7 +130,7 @@
   show = showDisjointSet
 
 showDisjointSet :: (Show a, Ord a) => DisjointSet a -> String
-showDisjointSet = show . toLists
+showDisjointSet = showString "fromLists " . show . toLists
 
 pretty :: (Ord a, Show a) => DisjointSet a -> String
 pretty xs = id
@@ -86,20 +143,17 @@
 applyList [] = id
 applyList (f : fs) = f . applyList fs
 
-toLists :: Ord a => DisjointSet a -> [[a]]
+toLists :: DisjointSet a -> [[a]]
 toLists = map S.toList . toSets
 
-toSets :: Ord a => DisjointSet a -> [Set a]
-toSets = M.elems . flatten
+-- this definition is pretty awful. Come up with something that
+-- behaves a little more reasonably in the presence of failure.
+fromLists :: Ord a => [[a]] -> DisjointSet a
+fromLists xs = fromMaybe empty (fromSets (map S.fromList xs))
 
--- in the result of this, the key in the
--- map keeps everything separate.
-flatten :: Ord a => DisjointSet a -> Map a (Set a)
-flatten ds@(DisjointSet p _) = S.foldl'
-  ( \m a -> case find a ds of
-    Nothing -> error "DisjointSet flatten: invariant violated. missing key."
-    Just b -> M.insertWith S.union b (S.singleton a) m
-  ) M.empty (M.keysSet p)
+toSets :: DisjointSet a -> [Set a]
+toSets (DisjointSet _ r) = M.foldr
+  (\(RankChildren _ s) xs -> s : xs) [] r
 
 {-|
 Create an equivalence relation between x and y. If either x or y
@@ -112,17 +166,18 @@
   repy <- lift $ state $ lookupCompressAdd y
   guard $ repx /= repy
   DisjointSet p r <- lift get
-  let rankx = r M.! repx
-  let ranky = r M.! repy
+  let RankChildren rankx keysx = r M.! repx
+  let RankChildren ranky keysy = r M.! repy
+      keys = mappend keysx keysy
   lift $ put $! case compare rankx ranky of
     LT -> let p' = M.insert repx repy p
-              r' = M.delete repx r
+              r' = M.delete repx $! M.insert repy (RankChildren ranky keys) r
           in  DisjointSet p' r'
     GT -> let p' = M.insert repy repx p
-              r' = M.delete repy r
+              r' = M.delete repy $! M.insert repx (RankChildren rankx keys) r
           in  DisjointSet p' r'
     EQ -> let p' = M.insert repx repy p
-              r' = M.delete repx $! M.insert repy (ranky + 1) r
+              r' = M.delete repx $! M.insert repy (RankChildren (ranky + 1) keys) r
           in  DisjointSet p' r'
 
 {-|
@@ -138,6 +193,23 @@
   y <- representative b ds
   Just (x == y)
 
+{-| All elements the are considered equal to the value. In the event
+    that the element does not exist, a singleton set will be returned.
+-}
+equivalences :: Ord a => a -> DisjointSet a -> Set a
+equivalences a (DisjointSet p r) = case M.lookup a p of
+  Nothing -> S.singleton a
+  Just b -> case M.lookup (lookupUntilRoot b p) r of
+    Nothing -> error "Data.DisjointSet equivalences: invariant violated"
+    Just (RankChildren _ s) -> s
+
+lookupUntilRoot :: Ord a => a -> Map a a -> a
+lookupUntilRoot a m = case M.lookup a m of
+  Nothing -> a
+  Just a' -> if a == a'
+    then a
+    else lookupUntilRoot a' m
+
 {-| Count the number of disjoint sets -}
 sets :: DisjointSet a -> Int
 sets (DisjointSet _ r) = M.size r
@@ -156,14 +228,14 @@
     in  case l of
           Just _  -> set
           Nothing ->
-              let r' = M.insert x 0 r
+              let r' = M.insert x (RankChildren 0 (S.singleton x)) r
               in  DisjointSet p' r'
 
 {-| Create a disjoint set with one member. O(1). -}
 singleton :: a -> DisjointSet a
 singleton !x =
   let p = M.singleton x x
-      r = M.singleton x 0
+      r = M.singleton x (RankChildren 0 (S.singleton x))
    in DisjointSet p r
 
 {-| Create a disjoint set with a single set containing two members -}
@@ -191,7 +263,8 @@
   Nothing -> empty
   Just x ->
     let p = M.fromSet (\_ -> x) s
-        r = M.singleton x 1
+        rank = if S.size s == 1 then 0 else 1
+        r = M.singleton x (RankChildren rank s)
     in DisjointSet p r
 
 setLookupMin :: Set a -> Maybe a
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 import Test.QuickCheck
 import Data.Word
@@ -7,7 +9,11 @@
 import Data.DisjointMap (DisjointMap)
 import Data.Set (Set)
 import Data.Foldable (toList)
+import Test.QuickCheck.Classes (jsonProps)
+import Data.Proxy (Proxy(..))
+import Data.Aeson (ToJSON,FromJSON)
 import qualified Data.Foldable as F
+import qualified Data.Set as S
 import qualified Data.DisjointSet as DS
 import qualified Data.DisjointMap as DM
 import qualified GHC.OldList as L
@@ -18,7 +24,16 @@
   quickCheck propUnionAll
   quickCheck propUnionAppend
   quickCheck propSingletons
+  quickCheck propEquivalances
   quickCheck propMapUnionAppend
+  putStrLn "* Disjoint Set JSON"
+  F.forM_ (jsonProps (Proxy :: Proxy (DisjointSet Word8))) $ \(name,p) -> do
+    putStrLn name
+    quickCheck p
+  putStrLn "* Disjoint Map JSON"
+  F.forM_ (jsonProps (Proxy :: Proxy (DisjointMap Word8 WrapWord8))) $ \(name,p) -> do
+    putStrLn name
+    quickCheck p
 
 propUnionAll :: [Word] -> Bool
 propUnionAll xs =
@@ -48,6 +63,12 @@
 propSingletons :: [Set Word] -> Bool
 propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs
 
+propEquivalances :: [(Word,Word)] -> Bool
+propEquivalances xs =
+  let s = foldMap (\(a,b) -> DS.singletons (S.fromList [a,b])) xs
+      All r = foldMap (\(a,b) -> All $ DS.equivalences a s == DS.equivalences b s) xs
+   in r
+
 splitList :: [a] -> ([a],[a])
 splitList xs =
   let halfLen = div (L.length xs) 2
@@ -79,3 +100,27 @@
 unionMapPairsGo :: (Ord k, Monoid v) => [(k,k)] -> DisjointMap k v -> DisjointMap k v
 unionMapPairsGo [] !ds = ds
 unionMapPairsGo ((a,b):xs) !ds = unionMapPairsGo xs (DM.union a b ds)
+
+instance (Arbitrary a, Ord a) => Arbitrary (DisjointSet a) where
+  arbitrary = do
+    xs <- arbitrary
+    ys <- arbitrary
+    let s1 = foldMap (\(a,b) -> DS.doubleton a b) (xs :: [(a,a)])
+        s2 = foldMap DS.singleton (ys :: [a])
+    return (s1 <> s2)
+
+instance (Arbitrary k, Ord k, Monoid v, Arbitrary v) => Arbitrary (DisjointMap k v) where
+  arbitrary = do
+    xs <- arbitrary
+    ys <- arbitrary
+    let s1 = foldMap (\(k,v) -> DM.singleton k v) (xs :: [(k,v)])
+        s2 = foldMap (\(k1,k2) -> DM.union k1 k2 DM.empty) (ys :: [(k,k)])
+    return (s1 <> s2)
+
+newtype WrapWord8 = WrapWord8 Word8
+  deriving (FromJSON,ToJSON,Show,Eq,Arbitrary,Ord)
+
+instance Monoid WrapWord8 where
+  mempty = WrapWord8 0
+  mappend (WrapWord8 a) (WrapWord8 b) = WrapWord8 (a + b)
+